MacTech 1 to 12/MacTech-vol-1-12.toast/Source/MacTech® Magazine/Volume 06 - 1990/06.10 Oct 90/LZW Source/LComp.p

Text File | 1989-05-07 | 16.3 KB | 597 lines | [TEXT/MPS ]

{$R-}
{$D+}
{$DEFC DEBUG}
{$SETC DEBUG=TRUE}
PROGRAM LComp;

{ Simple case LZW compression }

USES
    MemTypes,
    QuickDraw,
    OSIntf,
    ToolIntf,
    PackIntf;

CONST
    maxBuff = 8192;        {i/o buffer size}
    maxTab = 16383;        {Table size minus 1 ($3FFF)}
    noPrev = $7FFF;
    eofChar = -2;
    endList = -1;
    empty = -3;
    clearCode = 256;    {Reserved code to signal adaptive reset ($100) }
    checkGap = 10000;    {How frequently do we check for adaptive?}

TYPE
    StringTableEntry = RECORD
        prevByte: Integer;
        follByte: Integer;
        next: Integer;
        used: Boolean;
        reserved: Boolean;
    END;
    StringTableArray = ARRAY [0..maxTab] OF StringTableEntry; {128K structure unless packed}
    StringTablePtr = ^StringTableArray;
    IntPtr = ^Integer;
    Buffer = PACKED ARRAY [1..maxBuff] OF Char;
    BufPtr = ^Buffer;
    HeaderRecord = RECORD
        name: String[31];
        dfSize: LongInt;
        rfSize: LongInt;
        fndrInfo: FInfo;
    END;
    Remainder = (none, sixBit, fourBit, twoBit);

VAR
    inRef: Integer;                    {Reference number of input file}
    outRef: Integer;                {Reference number of output file}
    inVRefNum: Integer;            {Volume/WD reference number of input file}
    outVRefNum: Integer;        {Volume/WD reference number of output file}
    eofSignal: Boolean;            {Flag that it's time to clean up}
    inBufSize: LongInt;            {Count of characters in the input buffer }
    inputPos: Integer;            {Position in input buffer}
    outputPos: Integer;            {Position in output buffer}
    bytesRead: LongInt;            {Total bytes read from input file}
    bytesWritten: LongInt;    {Total bytes written to output file}
    ratio: Extended;                {Compression ratio (bytesRead/bytesWritten)}
    checkPoint: LongInt;        {Next time we check to see whether table adaptation necessary}

    inputBuffer: BufPtr;        {Dynamically allocated data storage}
    outputBuffer: BufPtr;        { " }

    stringTable: StringTablePtr;
    infileName:    Str255;            {Name of the file we're compressing}
    tableUsed: Integer;            {Number of entries currently in string table}
    outputCode: Integer;        {Code (14-bit) that we're going to output}
    carryOver: Remainder;        {How many bits we have in the code we're building}
    doingDFork: Boolean;        {Flag that tells which fork of the file we're compressing}
    fsErr: OSErr;                        {Result of last file system call}
    dataForkSize: LongInt;    {Number of bytes in data fork}
    rsrcForkSize: LongInt;    {Number of bytes in resource fork}
    progWindow: WindowPtr;    {Window where we display progress}
    boundsRect: Rect;                {Bounding rect of the progress window}
    hdrRec: HeaderRecord;        {File information so that decompress will get things right}
    resetCode: Integer;            {This is the hashCode for clearCode}


    PROCEDURE _DataInit; EXTERNAL;    {MPW specific}


    PROCEDURE FileAlert(str: Str255);

    CONST
        fsAlert =    1111;

    VAR
        item: Integer;

    BEGIN
        ParamText(str, '', '', '');
        item := StopAlert(fsAlert, NIL);
        fsErr := FSClose(inRef);
        fsErr := FSClose(outRef);
        fsErr := FlushVol(NIL, outVRefnum);
    END {FileAlert} ;


{$IFC DEBUG}
    PROCEDURE DebugAlert(l1, l2: LongInt);

    CONST
        dbgAlert = 1112;

    VAR
        s1, s2: Str255;
        item: Integer;

    BEGIN
        NumToString(l1, s1);
        NumToString(l2, s2);
        ParamText(s1, s2, '', '');
        item := NoteAlert(dbgAlert, NIL);
    END {DebugAlert} ;
{$ENDC}

    PROCEDURE ShowProgress;

    VAR
        savePort: GrafPtr;
        aStr: Str255;

    BEGIN
        GetPort(savePort);
        SetPort(progWindow);
        EraseRect(progWindow^.portRect);
        NumToString(bytesWritten, aStr);
        MoveTo(5, 10);
        DrawString(aStr);
        NumToString(bytesRead, aStr);
        MoveTo(5, 25);
        DrawString(aStr);
        NumToString(tableUsed, aStr);
        MoveTo(5, 40);
        DrawString(aStr);
        SetPort(savePort);
    END {ShowProgress} ;


    FUNCTION HashIt(prevC, follC: Integer): Integer;
    {"Dumb" hash routine, must match the routine in decompress}

    VAR
        temp,
        local: LongInt;

    BEGIN
        {Possible alternative commented out below}
{        local := BOR((prevC+follC), $00008000);
        temp := local * local;
        local := BAND(BSR(temp, 7), maxTab);    }

        HashIt := BAND(BXOR(BSL(prevC, 5), follC), maxTab);
    END {HashIt} ;


    FUNCTION GetHashCode(prevC, follC: Integer): Integer;
    {    Return value is the hash code for <w>c string }

    VAR
        index: Integer;
        index2: Integer;

    BEGIN
        index := HashIt(prevC, follC);

        {If the entry isn't already used we have a hash code}
        IF (stringTable^[index].used) THEN BEGIN
            {Entry already used, skip to end of collision list}
            WHILE stringTable^[index].next <> endList DO
                index := stringTable^[index].next;
            {Begin a linear probe down a bit from last entry in the collision list}
            index2 := BAND(index + 101, maxTab);
            {Look for an unused entry using linear probing}
            WHILE stringTable^[index2].used DO
                index2 := BAND(Succ(index2), maxTab);
            {Point the previous end of collision list at this new node}
            stringTable^[index].next := index2;
            GetHashCode := index2;
        END ELSE GetHashCode := index;
    END {GetHashCode} ;


    PROCEDURE MakeTableEntry(prevC, follC: Integer);

    VAR
        aCode: Integer;

    BEGIN
        IF tableUsed <= maxTab THEN BEGIN
            aCode := GetHashCode(prevC, follC);
            WITH stringTable^[aCode] DO BEGIN
                used := true;
                next := endList;
                prevByte := prevC;
                follByte := follC;
            END;

            tableUsed := tableUsed + 1;
        END;
    END {MakeTableEntry} ;


    FUNCTION LookupString(prevC, follC: Integer): Integer;

    VAR
        index: Integer;
        found: Boolean;
        myEntry: StringTableEntry;

    BEGIN
        index := HashIt(prevC, follC);
        LookupString := endList;
        found := FALSE;
        {    Search list of collision entries for one that matches <w>c }
        REPEAT
            myEntry := stringTable^[index];
            IF (myEntry.prevByte = prevC) &
                 (myEntry.follByte = follC) THEN found := true
            ELSE index := myEntry.next;
        UNTIL found OR (index = endList);
        { Return index if <w>c found, endList otherwise }
        IF found THEN LookupString := index;
    END {LookupString} ;


    PROCEDURE GetChar(VAR c: Integer);
    { Read a character from the input file.  If the input file is the data fork
        and at the end.  Close it and open the resource fork, inputting from it. }

    VAR
        logEOF: LongInt;

    BEGIN
        inputPos := inputPos + 1;
        IF inputPos > inBufSize THEN BEGIN
            inBufSize := maxBuff;
            fsErr := FSRead(inRef, inBufSize, Ptr(inputBuffer));
            inputPos := 1;
        END;
        IF inBufSize = 0 THEN BEGIN {We're in a possible eof situation}
            IF doingDFork THEN BEGIN {Check for the resource fork}
                doingDFork := false;
                fsErr := FSClose(inRef);
                fsErr := OpenRF(infileName, inVRefnum, inRef);
                IF fsErr = noErr THEN BEGIN
                    fsErr := GetEOF(inRef, logEOF);
                    rsrcForkSize := logEOF;
                    hdrRec.rfSize := logEOF;
                    fsErr := SetFPos(inRef, fsFromStart, 0);
                    inputPos := 1;
                    inBufSize := maxBuff;
                    fsErr := FSRead(inRef, inBufSize, Ptr(inputBuffer));
                    IF inBufSize = 0 THEN BEGIN {Empty resource fork}
                        c := eofChar;
                        eofSignal := true;
                    END ELSE BEGIN
                        c := Ord(inputBuffer^[inputPos]);
                        bytesRead := bytesRead + 1;
                    END;
                END ELSE BEGIN    {No resource fork, we're done!}
                    rsrcForkSize := 0;
                    hdrRec.rfSize := 0;
                    eofSignal := true;
                    c := eofChar;
                    Exit(GetChar);
                END;
            END ELSE BEGIN    {We are done, eof has been reached!}
                eofSignal := true;
                c := eofChar;
            END;
        END ELSE BEGIN
            c := Ord(inputBuffer^[inputPos]);
            bytesRead := bytesRead + 1;
        END;
    END {GetChar} ;


    PROCEDURE PutChar(c: Integer);

    VAR
        count: LongInt;

    BEGIN
        IF outputPos >= maxBuff THEN BEGIN
            count := maxBuff;
            fsErr := FSWrite(outRef, count, Ptr(outputBuffer));
            IF fsErr <> noErr THEN FileAlert('Write error in PutChar');
            outputPos := 0;
            ShowProgress;
        END;
        outputPos := outputPos + 1;
        bytesWritten := bytesWritten + 1;
        outputBuffer^[outputPos] := Chr(c);
    END {PutChar} ;


    PROCEDURE InitStrTable;

    VAR
        i: Integer;

    BEGIN
        tableUsed := 0;
        FOR i := 0 TO maxTab DO BEGIN
            WITH stringTable^[i] DO BEGIN
                prevByte := noPrev;
                follByte := noPrev;
                next := -1;
                used := false;
                reserved := false;
            END;
        END;
        {Enter all single ascii characters into the string table}
        FOR i := 0 TO clearCode DO
            MakeTableEntry(noPrev, i);
    END {InitStrTable} ;


    PROCEDURE Initialize;

        PROCEDURE InitManagers;

        BEGIN
            MaxApplZone;
            InitGraf(@thePort);
            InitFonts;
            FlushEvents(everyEvent, 0);
            InitWindows;
            InitMenus;
            TEInit;
            InitDialogs(NIL);
            InitCursor;
            UnLoadSeg(@_DataInit);    {MPW-specific unload}
        END {InitManagers} ;

    BEGIN
        InitManagers;

        inputBuffer := BufPtr(NewPtr(SizeOf(Buffer)));
        outputBuffer := BufPtr(NewPtr(SizeOf(Buffer)));
        stringTable := StringTablePtr(NewPtr(SizeOf(StringTableArray)));

        inBufSize := 0;
        inputPos := 1;    {With inBufSize set to zero this will force the 1st read}
        outputPos := 0;
        bytesRead := 0;
        bytesWritten := 0;
        doingDFork := true;
        outputCode := empty;
        carryOver := none;
        dataForkSize := 0;
        rsrcForkSize := 0;
        ratio := 0.0;
        checkPoint := checkGap;

        InitStrTable;
        resetCode := LookupString(noPrev, clearCode);
    END {Initialize} ;


    PROCEDURE GetTopLeft({using} dlogID: Integer;
                                             {returning} VAR where: Point);
    {    —    Return the point where DLOG(dlogID) should have its top-left corner so as
        —    to be centered in the area below the menubar of the main screen.  The
        —    centering is horizontal, vertically it should be one-third of the way.  This
        —    is achieved by getting the DLOG resource and centering its rectangle within
        —    screenBits.bounds after adjusting screenBits.bounds by mBarHeight. }

    CONST
        mBarHeight = $0BAA;    {Address of global integer containing menu bar height}

    VAR
        screenRect,
        dlogRect:    Rect;
        mBarAdjustment: IntPtr;
        aDlog: DialogTHndl;

    BEGIN
        screenRect := screenBits.bounds;
        mBarAdjustment := IntPtr(mBarHeight);
        screenRect.top := screenRect.top + mBarAdjustment^;
        aDlog := DialogTHndl(GetResource('DLOG', dlogID));
        DetachResource(Handle(aDlog));
        dlogRect := aDlog^^.boundsRect;
        WITH screenRect DO BEGIN
            where.v := ((bottom - top) - (dlogRect.bottom - dlogRect.top)) DIV 3;
            where.h := ((right - left) - (dlogRect.right - dlogRect.left)) DIV 2;
        END;
    END {GetTopLeft};


    FUNCTION GetInputFile({returning} VAR refNum: Integer): Boolean;
    { — Return false if the user cancels the request, true otherwise.  If a file
        —    is selected for compression, open the file and pass back the refnum.
        —    The constant getDlgID is from PackIntf.
        —    Global side-effects of this routine include the initialization of a number
        —    of fields of the hdrRec global and the setting of the inVRefNum global.}

    CONST
        allFiles = -1;

    VAR
        tl: Point;
        reply: SFReply;
        typeList: SFTypeList;
        anErr,
        error: OSErr;
        finderInfo: FInfo;
        logEOF: LongInt;
        dtRec: DateTimeRec;

    BEGIN
        GetTopLeft(getDlgID, tl);
        {typeList doesn't need to be initialized since we're asking for all files with the -1}
        SFGetFile(tl, '', NIL, allFiles, typeList, NIL, reply);
        IF reply.good THEN BEGIN
            error := FSOpen(reply.fName, reply.vRefnum, refNum);
            inVRefNum := reply.vRefnum;
            IF error = noErr THEN error := SetFPos(refNum, fsFromStart, 0)
            ELSE anErr := FSClose(refNum);
            IF error = noErr THEN BEGIN
                GetInputFile := true;
                infileName := reply.fName;
                anErr := GetEOF(refNum, logEOF);
                dataForkSize := logEOF;
                rsrcForkSize := 0;    {for the moment -- corrected when the resource fork is opened}
                hdrRec.name := infileName;
                hdrRec.dfSize := dataForkSize;
                anErr := GetFInfo(reply.fName, inVRefnum, finderInfo);
                hdrRec.fndrInfo := finderInfo;
            END ELSE GetInputFile := false;
        END ELSE GetInputFile := false;
    END {GetInputFile} ;


    FUNCTION GetOutputFile({returning} VAR refNum: Integer): Boolean;

    VAR
        tl: Point;
        reply: SFReply;
        error: OSErr;
        count: LongInt;

    BEGIN
        GetTopLeft(putDlgID, tl);
        SFPutFile(tl, '', '', NIL, reply);
        IF reply.good THEN BEGIN
            error := FSOpen(reply.fName, reply.vRefnum, refNum);
            IF error <> noErr THEN BEGIN    {File didn't already exist, need to create it}
                error := Create(reply.fName, reply.vRefnum, 'LZWC', 'DATA');
                IF error = noErr THEN error := FSOpen(reply.fName, reply.vRefnum, refNum);
                IF error = noErr THEN BEGIN
                    error := SetFPos(refNum, fsFromStart, 0);
                    count := SizeOf(HeaderRecord);
                    error := FSWrite(refNum, count, @hdrRec);
                END ELSE error := FSClose(refNum);
            END;
            IF error = noErr THEN BEGIN
                GetOutputFile := true;
                outVRefNum := reply.vRefnum;
            END ELSE GetOutputFile := false;
        END ELSE GetOutputFile := false;
    END {GetOutputFile} ;


    PROCEDURE Terminate;

    VAR
        count: LongInt;

    BEGIN
        ShowProgress;
        count := outputPos;
        fsErr := FSWrite(outRef, count, Ptr(outputBuffer));
        IF fsErr = noErr THEN BEGIN
            fsErr := SetEOF(outRef, bytesWritten+SizeOf(HeaderRecord));
            IF fsErr = noErr THEN BEGIN
                fsErr := SetFPos(outRef, fsFromStart, 0);
                IF fsErr = noErr THEN BEGIN
                    count := SizeOf(HeaderRecord);
                    fsErr := FSWrite(outRef, count, @hdrRec);
                    IF (fsErr <> noErr) | (count <> SizeOf(hdrRec)) THEN
                        FileAlert('Header update error in Terminate');
                END ELSE FileAlert('Positioning error in Terminate');
                fsErr := FSClose(outRef);
                fsErr := FSClose(inRef);
                fsErr := FlushVol(NIL, outVRefNum);
            END ELSE FileAlert('SetEOF Error in Terminate');
        END ELSE FileAlert('Write Error in Terminate');
    END {Terminate} ;


    PROCEDURE PutCode(hashCode: Integer);
    {    If the output code word is empty, then put out the first 8 bits of the
        compression code and save the last six bits for the next time through.
        If it's not empty, then put out the (saved) n bits from above prepended
        to the first 8-n bits of the new code.  Then put out the last eight
        bits of this code. }

    BEGIN
        IF carryOver = none THEN BEGIN
            PutChar(BAND(BSR(hashCode, 6), $00FF));        {most significant 8 bits}
            outputCode := BAND(hashCode, $003F);            {save 6 lsb for next time}
            carryOver := sixBit;
        END ELSE IF carryOver = twoBit THEN BEGIN
            PutChar(BAND(BSL(outputCode, 6), $00C0) +
                            BAND(BSR(hashCode, 8), $003F));        {leftover 2 + first 6}
            PutChar(BAND(hashCode, $00FF));                        {least significant 8 bits}
            outputCode := empty;                                            {nothing left}
            carryOver := none;
        END ELSE IF carryOver = fourBit THEN BEGIN
            PutChar(BAND(BSL(outputCode, 4), $00F0) +
                            BAND(BSR(hashCode, 10), $000F));    {leftover 4 + 4 msbits}
            PutChar(BAND(BSR(hashCode, 2), $00FF));        {next 8 bits}
            outputCode := BAND(hashCode, $0003);            {save these two bits}
            carryOver := twoBit;
        END ELSE IF carryOver = sixBit THEN BEGIN
            PutChar(BAND(BSL(outputCode, 2), $00FC) +
                            BAND(BSR(hashCode, 12), $0003));    {leftover 6 + first 2 bits}
            PutChar(BAND(BSR(hashCode, 4), $00FF));        {next 8 bits}
            outputCode := BAND(hashCode, $000F);            {four bits left}
            carryOver := fourBit;
        END;
    END {PutCode} ;


    PROCEDURE CheckReset;
    {    -- CheckReset tests the compression ratio to guarantee that it is monotonic
        -- increasing.  It modifies the global variables ratio and checkPoint.  If
        -- the compression ratio has decreased since the last checkPoint, the string
        -- table is reinitialized, the code for a clearCode is issued to the output,
        -- and ratio is reset to zero. }

    VAR
        e1, e2, temp: Extended;

    BEGIN
        {    Set the next checkPoint for checkGap from now }
        checkPoint := bytesRead + checkGap;
        e1 := bytesRead;
        e2 := bytesWritten;
        temp := e1 / e2;
        IF temp >= ratio THEN ratio := temp
        ELSE BEGIN
            ratio := 0.0;
            InitStrTable;
            PutCode(resetCode);
        END;
    END {CheckReset} ;


    PROCEDURE DoCompression;

    VAR
        c: Integer;
        w: Integer;
        wc: Integer;
        anEvent: EventRecord;

    BEGIN
        GetChar(c);
        w := LookupString(noPrev, c);
        GetChar(c);
        WHILE c <> eofChar DO BEGIN
            wc := LookupString(w, c);
            IF (wc = endList) THEN BEGIN
                PutCode(w);
                IF GetNextEvent(everyEvent, anEvent) THEN ;
                IF tableUsed <= maxTab THEN MakeTableEntry(w, c)
                ELSE IF bytesRead >= checkPoint THEN CheckReset;
                w := LookupString(noPrev, c)
            END ELSE w := wc;
            GetChar(c);
        END;
        PutCode(w);

        {Flush any remaining partial code to disk}
        IF carryOver = sixBit THEN PutChar(BAND(BSL(outputCode, 2), $00FC))
        ELSE IF carryOver = fourBit THEN PutChar(BAND(BSL(outputCode, 4), $00F0))
        ELSE IF carryOver = twoBit THEN PutChar(BAND(BSL(outputCode, 6), $00C0));
    END {DoCompression} ;

BEGIN
    Initialize;
    IF GetInputFile(inRef) THEN
        IF GetOutputFile(outRef) THEN BEGIN
            SetRect(boundsRect, 100, 50, 250, 100);
            progWindow := NewWindow(NIL, boundsRect, 'Bytes Read',
                    true, noGrowDocProc, Pointer(-1), false, 0);
            DoCompression;
            Terminate;
{$IFC DEBUG}
            DebugAlert(bytesRead, bytesWritten);
{$ENDC}
        END;
END.